home *** CD-ROM | disk | FTP | other *** search
/ Skunkware 98 / Skunkware 98.iso / src / interp / perl5.005.tar.gz / perl5.005.tar / perl5.005 / lib / Test.pm < prev    next >
Text File  |  1998-05-14  |  7KB  |  236 lines
  1. use strict;
  2. package Test;
  3. use Test::Harness 1.1601 ();
  4. use Carp;
  5. use vars (qw($VERSION @ISA @EXPORT $ntest $TestLevel), #public-ish
  6.       qw($ONFAIL %todo %history $planned @FAILDETAIL)); #private-ish
  7. $VERSION = '1.04';
  8. require Exporter;
  9. @ISA=('Exporter');
  10. @EXPORT= qw(&plan &ok &skip $ntest);
  11.  
  12. $TestLevel = 0;        # how many extra stack frames to skip
  13. $|=1;
  14. #$^W=1;  ?
  15. $ntest=1;
  16.  
  17. # Use of this variable is strongly discouraged.  It is set mainly to
  18. # help test coverage analyzers know which test is running.
  19. $ENV{REGRESSION_TEST} = $0;
  20.  
  21. sub plan {
  22.     croak "Test::plan(%args): odd number of arguments" if @_ & 1;
  23.     croak "Test::plan(): should not be called more than once" if $planned;
  24.     my $max=0;
  25.     for (my $x=0; $x < @_; $x+=2) {
  26.     my ($k,$v) = @_[$x,$x+1];
  27.     if ($k =~ /^test(s)?$/) { $max = $v; }
  28.     elsif ($k eq 'todo' or 
  29.            $k eq 'failok') { for (@$v) { $todo{$_}=1; }; }
  30.     elsif ($k eq 'onfail') { 
  31.         ref $v eq 'CODE' or croak "Test::plan(onfail => $v): must be CODE";
  32.         $ONFAIL = $v; 
  33.     }
  34.     else { carp "Test::plan(): skipping unrecognized directive '$k'" }
  35.     }
  36.     my @todo = sort { $a <=> $b } keys %todo;
  37.     if (@todo) {
  38.     print "1..$max todo ".join(' ', @todo).";\n";
  39.     } else {
  40.     print "1..$max\n";
  41.     }
  42.     ++$planned;
  43. }
  44.  
  45. sub to_value {
  46.     my ($v) = @_;
  47.     (ref $v or '') eq 'CODE' ? $v->() : $v;
  48. }
  49.  
  50. # STDERR is NOT used for diagnostic output which should have been
  51. # fixed before release.  Is this appropriate?
  52.  
  53. sub ok ($;$$) {
  54.     croak "ok: plan before you test!" if !$planned;
  55.     my ($pkg,$file,$line) = caller($TestLevel);
  56.     my $repetition = ++$history{"$file:$line"};
  57.     my $context = ("$file at line $line".
  58.            ($repetition > 1 ? " fail \#$repetition" : ''));
  59.     my $ok=0;
  60.     my $result = to_value(shift);
  61.     my ($expected,$diag);
  62.     if (@_ == 0) {
  63.     $ok = $result;
  64.     } else {
  65.     $expected = to_value(shift);
  66.     # until regex can be manipulated like objects...
  67.     my ($regex,$ignore);
  68.     if (($regex) = ($expected =~ m,^ / (.+) / $,sx) or
  69.         ($ignore, $regex) = ($expected =~ m,^ m([^\w\s]) (.+) \1 $,sx)) {
  70.         $ok = $result =~ /$regex/;
  71.     } else {
  72.         $ok = $result eq $expected;
  73.     }
  74.     }
  75.     if ($todo{$ntest}) {
  76.     if ($ok) { 
  77.         print "ok $ntest # Wow! ($context)\n";
  78.     } else {
  79.         $diag = to_value(shift) if @_;
  80.         if (!$diag) {
  81.         print "not ok $ntest # (failure expected in $context)\n";
  82.         } else {
  83.         print "not ok $ntest # (failure expected: $diag)\n";
  84.         }
  85.     }
  86.     } else {
  87.     print "not " if !$ok;
  88.     print "ok $ntest\n";
  89.     
  90.     if (!$ok) {
  91.         my $detail = { 'repetition' => $repetition, 'package' => $pkg,
  92.                'result' => $result };
  93.         $$detail{expected} = $expected if defined $expected;
  94.         $diag = $$detail{diagnostic} = to_value(shift) if @_;
  95.         if (!defined $expected) {
  96.         if (!$diag) {
  97.             print STDERR "# Failed test $ntest in $context\n";
  98.         } else {
  99.             print STDERR "# Failed test $ntest in $context: $diag\n";
  100.         }
  101.         } else {
  102.         my $prefix = "Test $ntest";
  103.         print STDERR "# $prefix got: '$result' ($context)\n";
  104.         $prefix = ' ' x (length($prefix) - 5);
  105.         if (!$diag) {
  106.             print STDERR "# $prefix Expected: '$expected'\n";
  107.         } else {
  108.             print STDERR "# $prefix Expected: '$expected' ($diag)\n";
  109.         }
  110.         }
  111.         push @FAILDETAIL, $detail;
  112.     }
  113.     }
  114.     ++ $ntest;
  115.     $ok;
  116. }
  117.  
  118. sub skip ($$;$$) {
  119.     if (to_value(shift)) {
  120.     print "ok $ntest # skip\n";
  121.     ++ $ntest;
  122.     1;
  123.     } else {
  124.     local($TestLevel) = $TestLevel+1;  #ignore this stack frame
  125.     &ok;
  126.     }
  127. }
  128.  
  129. END {
  130.     $ONFAIL->(\@FAILDETAIL) if @FAILDETAIL && $ONFAIL;
  131. }
  132.  
  133. 1;
  134. __END__
  135.  
  136. =head1 NAME
  137.  
  138.   Test - provides a simple framework for writing test scripts
  139.  
  140. =head1 SYNOPSIS
  141.  
  142.   use strict;
  143.   use Test;
  144.   BEGIN { plan tests => 13, todo => [3,4] }
  145.  
  146.   ok(0); # failure
  147.   ok(1); # success
  148.  
  149.   ok(0); # ok, expected failure (see todo list, above)
  150.   ok(1); # surprise success!
  151.  
  152.   ok(0,1);             # failure: '0' ne '1'
  153.   ok('broke','fixed'); # failure: 'broke' ne 'fixed'
  154.   ok('fixed','fixed'); # success: 'fixed' eq 'fixed'
  155.  
  156.   ok(sub { 1+1 }, 2);  # success: '2' eq '2'
  157.   ok(sub { 1+1 }, 3);  # failure: '2' ne '3'
  158.   ok(0, int(rand(2));  # (just kidding! :-)
  159.  
  160.   my @list = (0,0);
  161.   ok @list, 3, "\@list=".join(',',@list);      #extra diagnostics
  162.   ok 'segmentation fault', '/(?i)success/';    #regex match
  163.  
  164.   skip($feature_is_missing, ...);    #do platform specific test
  165.  
  166. =head1 DESCRIPTION
  167.  
  168. Test::Harness expects to see particular output when it executes tests.
  169. This module aims to make writing proper test scripts just a little bit
  170. easier (and less error prone :-).
  171.  
  172. =head1 TEST TYPES
  173.  
  174. =over 4
  175.  
  176. =item * NORMAL TESTS
  177.  
  178. These tests are expected to succeed.  If they don't, something's
  179. screwed up!
  180.  
  181. =item * SKIPPED TESTS
  182.  
  183. Skip tests need a platform specific feature that might or might not be
  184. available.  The first argument should evaluate to true if the required
  185. feature is NOT available.  After the first argument, skip tests work
  186. exactly the same way as do normal tests.
  187.  
  188. =item * TODO TESTS
  189.  
  190. TODO tests are designed for maintaining an executable TODO list.
  191. These tests are expected NOT to succeed (otherwise the feature they
  192. test would be on the new feature list, not the TODO list).
  193.  
  194. Packages should NOT be released with successful TODO tests.  As soon
  195. as a TODO test starts working, it should be promoted to a normal test
  196. and the newly minted feature should be documented in the release
  197. notes.
  198.  
  199. =back
  200.  
  201. =head1 ONFAIL
  202.  
  203.   BEGIN { plan test => 4, onfail => sub { warn "CALL 911!" } }
  204.  
  205. The test failures can trigger extra diagnostics at the end of the test
  206. run.  C<onfail> is passed an array ref of hash refs that describe each
  207. test failure.  Each hash will contain at least the following fields:
  208. package, repetition, and result.  (The file, line, and test number are
  209. not included because their correspondance to a particular test is
  210. fairly weak.)  If the test had an expected value or a diagnostic
  211. string, these will also be included.
  212.  
  213. This optional feature might be used simply to print out the version of
  214. your package and/or how to report problems.  It might also be used to
  215. generate extremely sophisticated diagnostics for a particular test
  216. failure.  It's not a panacea, however.  Core dumps or other
  217. unrecoverable errors will prevent the C<onfail> hook from running.
  218. (It is run inside an END block.)  Besides, C<onfail> is probably
  219. over-kill in the majority of cases.  (Your test code should be simpler
  220. than the code it is testing, yes?)
  221.  
  222. =head1 SEE ALSO
  223.  
  224. L<Test::Harness> and various test coverage analysis tools.
  225.  
  226. =head1 AUTHOR
  227.  
  228. Copyright ⌐ 1998 Joshua Nathaniel Pritikin.  All rights reserved.
  229.  
  230. This package is free software and is provided "as is" without express
  231. or implied warranty.  It may be used, redistributed and/or modified
  232. under the terms of the Perl Artistic License (see
  233. http://www.perl.com/perl/misc/Artistic.html)
  234.  
  235. =cut
  236.